home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-11 / advcpf.zip / DEMOFORT.FOR < prev    next >
Text File  |  1993-01-04  |  2KB  |  60 lines
  1. C FORTRAN DEMO (Calculates Distance between two points in 3D-ROOM.)
  2. C 
  3. $INCLUDE:'EX.F'
  4.       SUBROUTINE COORD
  5.       PARAMETER (CLIPPER='void pascal')
  6.       REAL*8 PARND
  7.       REAL A(3),B(3),DIST
  8.       INTEGER*2 IFHEL,DIM,LNG,ALNGTH,STRLEN     
  9.       INTEGER*2 WAHR,LOGIN
  10.       CHARACTER*7 LABEL(3)
  11.       LOGICAL*2 ISA,ISARRY
  12.       DATA LABEL/'X-COORD','Y-COORD','Z-COORD'/
  13. C PULL ARRAY's FROM CLIPPER      
  14.       DO 20 I=1,3
  15.       A(I)=PARND(1,I)
  16.       B(I)=PARND(2,I)
  17.       DIST=DIST+(A(I)-B(I))**2
  18. 20    CONTINUE
  19.       DIST=SQRT(DIST)
  20. C OUTPUT TO SCREEN, NOT VERY FANCY!
  21.       WRITE(*,*) '           Demo for a Clipper Fortran Conenction'
  22.       WRITE(*,*) '           (The screen I/O is done by Fortran)'
  23.       WRITE(*,*) '           Calculates the Distance between A - B'
  24.       WRITE(*,*) '                     JOBST HENSIEK'
  25.       WRITE(*,210)
  26. 210   FORMAT(/,14X,'Point A Point B')
  27.       WRITE(*,220) (LABEL(J),A(J),B(J),J=1,3)
  28. 220   FORMAT(2X,A7,2X,F7.2,2X,F7.2,/)
  29. C Checks for ARRAY
  30.       ISA=ISARRY(1)
  31. C
  32. C GIVES ARRAY LENGTH
  33.       DIM=ALNGTH(1)
  34. C
  35. C GET STRING-LENGTH
  36.       LNG=STRLEN(LABEL(1)//CHAR(0))
  37. C
  38. C TRANSFORM LOGICAL TO INTEGER IN ORDER TO PASS
  39.       WAHR=LOGIN(ISA)
  40.       WRITE(*,230) DIST,ISA,DIM,LNG
  41. 230   FORMAT(2X,'Distance A - B =',F9.2,//,
  42.      *2X,'Check for (1st Para), array: ',L2,/,2X,'Array-Dim: A[]  : ',I2,
  43.      */,2X,'String-Length   : ',I2)
  44. C      CLOSE(6)
  45. C
  46. C PUSH (DOUBLE)DIST back to CLIPPER
  47.       CALL STRND(DIST,3)
  48. C
  49. C
  50. C PUSH (LOGICAL(INTEGR))WAHR to CLIPPER
  51.       CALL STRL(1,4)
  52. C
  53. C
  54. C RETURN (INTEGER)IFEHL TO CLIPPER
  55. C  (PUT INTO X in Clipper.prg)
  56.       IFEHL=1
  57.       CALL RETNI(IFEHL)
  58.       END
  59.  
  60.